home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / trace.lisp < prev    next >
Lisp/Scheme  |  1992-08-06  |  16KB  |  459 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;; Trace works by substituting trace functions for the display-write/input functions.
  20. ;; The trace functions maintain a database of requests sent to the server in the
  21. ;; trace-history display property.  This is an alist of (id . byte-vector) where
  22. ;; id is the request number for writes, :reply for replies, :event for events and
  23. ;; :error for errors.  The alist is kept in reverse order (most recent first)
  24.  
  25. ;; In a multiprocessing system is it very helpful to know what process wrote or
  26. ;; read certain requests.  Thus I have modified the format of the trace-history
  27. ;; list.  It is now an alist of: ((id . more-info) . byte-vector).
  28. ;; (more-info is a list returned by the trace-more-info function).
  29. ;; Also added the ability to suspend and resume tracing without destroying the
  30. ;; trace history.  Renamed 'display-trace' to 'show-trace' to avoid confusion.
  31. ;; 7feb91 -- jdi
  32.  
  33. ;;; Created 09/14/87 by LaMott G. OREN
  34.  
  35. (in-package :xlib)
  36.  
  37. (eval-when (load eval)
  38.   (export '(trace-display
  39.         suspend-display-tracing
  40.         resume-display-tracing
  41.         untrace-display
  42.         show-trace
  43.         display-trace        ; for backwards compatibility
  44.         describe-request
  45.         describe-event
  46.         describe-reply
  47.         describe-error
  48.         describe-trace)))
  49.  
  50. (defun trace-display (display)
  51.   "Start a trace on DISPLAY.
  52.  If display is already being traced, this discards previous history.
  53.  See show-trace and describe-trace."  
  54.   (declare (type display display))
  55.   (unless (getf (display-plist display) 'write-function)
  56.     (bind-io-hooks display))
  57.   (setf (display-trace-history display) nil)
  58.   t)
  59.  
  60. (defun suspend-display-tracing (display)
  61.   "Tracing is suspended, but history is not cleared."
  62.   (if (getf (display-plist display) 'suspend-display-tracing)
  63.       (warn "Tracing is already suspend for ~s" display)
  64.     (progn
  65.       (unbind-io-hooks display)
  66.       (setf (getf (display-plist display) 'suspend-display-tracing) t))))
  67.  
  68. (defun resume-display-tracing (display)
  69.   "Used to resume tracing after suspending"
  70.   (if (getf (display-plist display) 'suspend-display-tracing)
  71.       (progn
  72.     (bind-io-hooks display)
  73.     (remf (display-plist display) 'suspend-display-tracing))
  74.     (warn "Tracing was not suspended for ~s" display)))
  75.   
  76. (defun untrace-display (display)
  77.   "Stop tracing DISPLAY."
  78.   (declare (type display display))
  79.   (if (not (getf (display-plist display) 'suspend-display-tracing))
  80.       (unbind-io-hooks display)
  81.     (remf (display-plist display) 'suspend-display-tracing))
  82.   (setf (display-trace-history display) nil))
  83.  
  84. ;; Assumes tracing is not already on.
  85. (defun bind-io-hooks (display)
  86.   (let ((write-function (display-write-function display))
  87.     (input-function (display-input-function display)))
  88.     ;; Save origional write/input functions so we can untrace
  89.     (setf (getf (display-plist display) 'write-function) write-function)
  90.     (setf (getf (display-plist display) 'input-function) input-function)
  91.     ;; Set new write/input functions that will record what's sent to the server
  92.     (setf (display-write-function display)
  93.       #'(lambda (vector display start end)
  94.       (trace-write-hook vector display start end)
  95.       (funcall write-function vector display start end)))
  96.     (setf (display-input-function display)
  97.       #'(lambda (display vector start end timeout)
  98.       (let ((result (funcall input-function
  99.                  display vector start end timeout)))
  100.         (unless result
  101.           (trace-read-hook display vector start end))
  102.         result)))))
  103.  
  104. (defun unbind-io-hooks (display)
  105.   (let ((write-function (getf (display-plist display) 'write-function))
  106.     (input-function (getf (display-plist display) 'input-function)))
  107.     (when write-function
  108.       (setf (display-write-function display) write-function))
  109.     (when input-function
  110.       (setf (display-input-function display) input-function))
  111.     (remf (display-plist display) 'write-function)
  112.     (remf (display-plist display) 'input-function)))
  113.   
  114.  
  115. (defun byte-ref16 (vector index)
  116.   #+clx-little-endian
  117.   (logior (the card16
  118.         (ash (the card8 (aref vector (index+ index 1))) 8))
  119.       (the card8
  120.         (aref vector index)))
  121.   #-clx-little-endian
  122.   (logior (the card16
  123.         (ash (the card8 (aref vector index)) 8))
  124.       (the card8
  125.         (aref vector (index+ index 1)))))
  126.  
  127. (defun byte-ref32 (a i)
  128.   (declare (type buffer-bytes a)
  129.        (type array-index i))
  130.   (declare (values card32))
  131.   (declare-buffun)
  132.   #+clx-little-endian
  133.   (the card32
  134.        (logior (the card32
  135.             (ash (the card8 (aref a (index+ i 3))) 24))
  136.            (the card29
  137.             (ash (the card8 (aref a (index+ i 2))) 16))
  138.            (the card16
  139.             (ash (the card8 (aref a (index+ i 1))) 8))
  140.            (the card8
  141.             (aref a i))))
  142.   #-clx-little-endian
  143.   (the card32
  144.        (logior (the card32
  145.             (ash (the card8 (aref a i)) 24))
  146.            (the card29
  147.             (ash (the card8 (aref a (index+ i 1))) 16))
  148.            (the card16
  149.             (ash (the card8 (aref a (index+ i 2))) 8))
  150.            (the card8
  151.             (aref a (index+ i 3))))))
  152.  
  153. (defun trace-write-hook (vector display start end)
  154.   ;; Called only by buffer-flush.  Start should always be 0
  155.   (unless (zerop start)
  156.     (format *debug-io* "write-called with non-zero start: ~d" start))
  157.   (let* ((history (display-trace-history display))
  158.      (request-number (display-request-number display))
  159.      (last-history (car history)))
  160.     ;; There may be several requests in the buffer, and the last one may be
  161.     ;; incomplete.  The first one may be the completion of a previous request.
  162.     ;; We can detect incomplete requests by comparing the expected length of
  163.     ;; the last request with the actual length.
  164.     (when (and last-history (numberp (caar last-history)))
  165.       (let* ((last-length (index* 4 (byte-ref16 (cdr last-history) 2)))
  166.          (append-length (min (- last-length (length (cdr last-history)))
  167.                  (- end start))))
  168.     (when (plusp append-length)
  169.       ;; Last history incomplete - append to last
  170.       (setf (cdr last-history)
  171.         (concatenate '(vector card8) (cdr last-history)
  172.              (subseq vector start (+ start append-length))))
  173.       (index-incf start append-length))))
  174.     ;; Copy new requests into the history
  175.     (do* ((new-history nil)
  176.       (i start (+ i length))
  177.       request
  178.       length)
  179.      ((>= i end)
  180.       ;; add in sequence numbers
  181.       (dolist (entry new-history)
  182.         (setf (caar entry) request-number)
  183.         (decf request-number))
  184.       (setf (display-trace-history display)
  185.         (nconc new-history history)))
  186.       (setq request (aref vector i))
  187.       (setq length (index* 4 (byte-ref16 vector (+ i 2))))
  188.       (when (zerop length)
  189.     (warn "Zero length in buffer")
  190.     (return nil))
  191.       (push (cons (cons 0 (trace-more-info display request vector
  192.                        i (min (+ i length) end)))
  193.           (subseq vector i (min (+ i length) end))) new-history)
  194.       (when (zerop request)
  195.     (warn "Zero length in buffer")
  196.     (return nil)))))
  197.  
  198. (defun trace-read-hook (display vector start end)
  199.   ;; Reading is done with an initial length of 32 (with start = 0)
  200.   ;; This may be followed by several other reads for long replies.
  201.   (let* ((history (display-trace-history display))
  202.      (last-history (car history))
  203.      (length (- end start)))
  204.     (when (and history (eq (caar last-history) :reply))
  205.       (let* ((last-length (index+ 32 (index* 4 (byte-ref32 (cdr last-history) 4))))
  206.          (append-length (min (- last-length (length (cdr last-history)))
  207.                  (- end start))))
  208.     (when (plusp append-length)
  209.       (setf (cdr last-history)
  210.         (concatenate '(vector card8) (cdr last-history)
  211.              (subseq vector start (+ start append-length))))
  212.       (index-incf start append-length)
  213.       (index-decf length append-length))))
  214.     
  215.     ;; Copy new requests into the history
  216.     (when (plusp length)
  217.       (let ((reply-type (case (aref vector start) (0 :error) (1 :reply)
  218.                   (otherwise :event))))
  219.     (push (cons (cons reply-type
  220.               (trace-more-info display reply-type vector start
  221.                        (+ start length)))
  222.             (subseq vector start (+ start length)))
  223.         (display-trace-history display))))))
  224.  
  225. (defun trace-more-info (display request-id vector start end)
  226.   (declare (ignore display request-id vector start end))
  227.   ;; Currently only returns current process.
  228.   #+allegro
  229.   (list mp::*current-process*))
  230.  
  231.  
  232. (defun show-trace (display &key length show-process)
  233.   "Display the trace history for DISPLAY.
  234.  The default is to show ALL history entries.
  235.  When the LENGTH parameter is used, only the last LENGTH entries are
  236.  displayed."
  237.   (declare (type display display))
  238.   (dolist (hist (reverse (subseq (display-trace-history display)
  239.                  0 length)))
  240.     (let* ((id (caar hist))
  241.        (more-info (cdar hist))
  242.        (vector (cdr hist))
  243.        (length (length vector))
  244.        (request (aref vector 0)))
  245.       (format t "~%~5d " id)
  246.       (case id
  247.     (:error
  248.      (trace-error-print display more-info vector))
  249.     (:event
  250.      (format t "~a (~d) Sequence ~d"
  251.          (if (< request (length *event-key-vector*))
  252.              (aref *event-key-vector* request)
  253.            "Unknown")
  254.          request
  255.          (byte-ref16 vector 2))
  256.      (when show-process
  257.        #+allegro
  258.        (format t ", Proc ~a" (mp::process-name (car more-info)))))
  259.     (:reply
  260.      (format t "To ~d length ~d"
  261.          (byte-ref16 vector 2) length)
  262.      (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
  263.        (unless (= length actual-length)
  264.          (format t " Should be ~d **************" actual-length)))
  265.      (when show-process
  266.        #+allegro
  267.        (format t ", Proc ~a" (mp::process-name (car more-info)))))
  268.     (otherwise
  269.      (format t "~a (~d) length ~d"
  270.          (request-name request) request length)
  271.      (when show-process
  272.        #+allegro
  273.        (format t ", Proc ~a" (mp::process-name (car more-info)))))))))
  274.  
  275. ;; For backwards compatibility
  276. (defun display-trace (&rest args)
  277.   (apply 'show-trace args))
  278.  
  279. (defun find-trace (display type sequence &optional (number 0))
  280.   (dolist (history (display-trace-history display))
  281.     (when (and (symbolp (caar history))
  282.            (= (logandc2 (aref (cdr history) 0) 128) type)
  283.            (= (byte-ref16 (cdr history) 2) sequence)
  284.            (minusp (decf number)))
  285.       (return (cdr history)))))
  286.  
  287. (defun describe-error (display sequence)
  288.   "Describe the error associated with request SEQUENCE."
  289.   (let ((vector (find-trace display 0 sequence)))
  290.     (if vector
  291.     (progn
  292.       (terpri)
  293.       (trace-error-print display nil vector))
  294.       (format t "Error with sequence ~d not found." sequence))))
  295.  
  296. (defun trace-error-print (display more-info vector
  297.               &optional (stream *standard-output*))
  298.   (declare (ignore more-info))
  299.   (let ((event (allocate-event)))
  300.     ;; Copy into event from reply buffer
  301.     (buffer-replace (reply-ibuf8 event)
  302.             vector
  303.             0
  304.             *replysize*)
  305.     (reading-event (event)
  306.       (let* ((type (read-card8 0))
  307.          (error-code (read-card8 1))
  308.          (sequence (read-card16 2))
  309.          (resource-id (read-card32 4))
  310.          (minor-code (read-card16 8))
  311.          (major-code (read-card8 10))
  312.          (current-sequence (ldb (byte 16 0) (buffer-request-number display)))
  313.          (error-key
  314.            (if (< error-code (length *xerror-vector*))
  315.            (aref *xerror-vector* error-code)
  316.          'unknown-error))
  317.          (params
  318.            (case error-key
  319.          ((colormap-error cursor-error drawable-error font-error gcontext-error
  320.                   id-choice-error pixmap-error window-error)
  321.           (list :resource-id resource-id))
  322.          (atom-error 
  323.           (list :atom-id resource-id))
  324.          (value-error
  325.           (list :value resource-id))
  326.          (unknown-error
  327.           ;; Prevent errors when handler is a sequence
  328.           (setq error-code 0)
  329.           (list :error-code error-code)))))
  330.     type
  331.     (let ((condition 
  332.         (apply #+lispm #'si:make-condition
  333.                #+allegro #'make-condition
  334.                #-(or lispm allegro) #'make-condition
  335.                error-key
  336.                :error-key error-key
  337.                :display display
  338.                :major major-code
  339.                :minor minor-code
  340.                :sequence sequence
  341.                :current-sequence current-sequence
  342.                params)))
  343.       (princ condition stream)
  344.       (deallocate-event event)
  345.       condition)))))
  346.  
  347. (defun describe-request (display sequence)
  348.   "Describe the request with sequence number SEQUENCE"
  349.   #+ti (si:load-if "clx:debug;describe")
  350.   (let ((request (assoc sequence (display-trace-history display)
  351.                :test #'(lambda (item key)
  352.                  (eql item (car key))))))
  353.     (if (null request)
  354.     (format t "~%Request number ~d not found in trace history" sequence)
  355.       (let* ((vector (cdr request))
  356.          (len (length vector))
  357.          (hist (make-reply-buffer len)))
  358.     (buffer-replace (reply-ibuf8 hist) vector 0 len)
  359.     (print-history-description hist)))))
  360.  
  361. (defun describe-reply (display sequence)
  362.   "Print the reply to request SEQUENCE.
  363.  (The current implementation doesn't print very pretty)"
  364.   (let ((vector (find-trace display 1 sequence))
  365.     (*print-array* t))
  366.     (if vector
  367.     (print vector)
  368.       (format t "~%Reply not found"))))
  369.  
  370. (defun event-number (name)
  371.   (if (integerp name)
  372.       (let ((name (logandc2 name 128)))
  373.     (if (typep name '(integer 0 63))
  374.         (aref *event-key-vector* name))
  375.     name)
  376.     (position (string name) *event-key-vector* :test #'equalp :key #'string)))
  377.  
  378. (defun describe-event (display name sequence &optional (number 0))
  379.   "Describe the event with event-name NAME and sequence number SEQUENCE.
  380. If there is more than one event, return NUMBER in the sequence."
  381.   (declare (type display display)
  382.        (type (or stringable (integer 0 63)) name)
  383.        (integer sequence))
  384.   (let* ((event (event-number name))
  385.      (vector (and event (find-trace display event sequence number))))
  386.     (if (not event)
  387.     (format t "~%~s isn't an event name" name)
  388.       (if (not vector)
  389.       (if (and (plusp number) (setq vector (find-trace display event sequence 0)))
  390.           (do ((i 1 (1+ i))
  391.            (last-vector))
  392.           (nil)
  393.         (if (setq vector (find-trace display event sequence i))
  394.             (setq last-vector vector)
  395.           (progn 
  396.             (format t "~%Event number ~d not found, last event was ~d"
  397.                 number (1- i))
  398.             (return (trace-event-print display last-vector)))))
  399.         (format t "~%Event ~s not found"
  400.             (aref *event-key-vector* event)))
  401.     (trace-event-print display vector)))))
  402.  
  403. (defun trace-event-print (display vector)
  404.   (let* ((event (allocate-event))
  405.      (event-code (ldb (byte 7 0) (aref vector 0)))
  406.      (event-decoder (aref *event-handler-vector* event-code)))
  407.     ;; Copy into event from reply buffer
  408.     (setf (event-code event) event-code)
  409.     (buffer-replace (reply-ibuf8 event)
  410.             vector
  411.             0
  412.             *replysize*)
  413.     (prog1 (funcall event-decoder display event
  414.             #'(lambda (&rest args &key send-event-p &allow-other-keys)
  415.             (setq args (copy-list args))
  416.             (remf args :display)
  417.             (remf args :event-code)
  418.             (unless send-event-p (remf args :send-event-p))
  419.             args))
  420.        (deallocate-event event))))
  421.  
  422. (defun describe-trace (display &optional length)
  423.   "Display the trace history for DISPLAY.
  424.  The default is to show ALL history entries.
  425.  When the LENGTH parameter is used, only the last LENGTH entries are
  426.  displayed."
  427.   (declare (type display display))
  428.   #+ti (si:load-if "clx:debug;describe")
  429.   (dolist (hist (reverse (subseq (display-trace-history display)
  430.                  0 length)))
  431.     (let* ((id (car hist))
  432.        (vector (cdr hist))
  433.        (length (length vector)))
  434.       (format t "~%~5d " id)
  435.       (case id
  436.     (:error
  437.      (trace-error-print display nil vector))
  438.     (:event
  439.      (let ((event (trace-event-print display vector)))
  440.        (when event (format t "from ~d ~{ ~s~}"
  441.                    (byte-ref16 vector 2) event))))
  442.     (:reply
  443.      (format t "To ~d length ~d"
  444.          (byte-ref16 vector 2) length)
  445.      (let ((actual-length (index+ 32 (index* 4 (byte-ref32 vector 4)))))
  446.        (unless (= length actual-length)
  447.          (format t " Should be ~d **************" actual-length)))
  448.      (let ((*print-array* t)
  449.            (*print-base* 16.))
  450.        (princ " ")
  451.        (princ vector)))
  452.     (otherwise
  453.       (let* ((len (length vector))
  454.          (hist (make-reply-buffer len)))
  455.         (buffer-replace (reply-ibuf8 hist) vector 0 len)
  456.         (print-history-description hist)))))))
  457.  
  458. ;; End of file
  459.